home *** CD-ROM | disk | FTP | other *** search
/ Personal Computer World 2009 February / PCWFEB09.iso / Software / Linux / Kubuntu 8.10 / kubuntu-8.10-desktop-i386.iso / casper / filesystem.squashfs / usr / share / apps / dcopidlng / kdocUtil.pm < prev   
Text File  |  2005-09-10  |  3KB  |  190 lines
  1.  
  2. package kdocUtil;
  3.  
  4. use strict;
  5.  
  6.  
  7. =head1 kdocUtil
  8.  
  9.     General utilities.
  10.  
  11. =head2 countReg
  12.  
  13.     Parameters: string, regexp
  14.  
  15.     Returns the number of times of regexp occurs in string.
  16.  
  17. =cut
  18.  
  19. sub countReg
  20. {
  21.     my( $str, $regexp ) = @_;
  22.     my( $count ) = 0;
  23.  
  24.     while( $str =~ /$regexp/s ) {
  25.         $count++;
  26.         
  27.         $str =~ s/$regexp//s;
  28.     }
  29.  
  30.     return $count;
  31. }
  32.  
  33. =head2 findCommonPrefix
  34.  
  35.     Parameters: string, string
  36.  
  37.     Returns the prefix common to both strings. An empty string
  38.     is returned if the strings have no common prefix.
  39.  
  40. =cut
  41.  
  42. sub findCommonPrefix
  43. {
  44.     my @s1 = split( "/", $_[0] );
  45.     my @s2 = split( "/", $_[1] );
  46.     my $accum = "";
  47.     my $len = ($#s2 > $#s1 ) ? $#s1 : $#s2;
  48.  
  49.     for my $i ( 0..$len ) {
  50. #        print "Compare: $i '$s1[$i]', '$s2[$i]'\n";
  51.         last if $s1[ $i ] ne $s2[ $i ];
  52.         $accum .= $s1[ $i ]."/";
  53.     }
  54.  
  55.     return $accum;
  56. }
  57.  
  58. =head2 makeRelativePath
  59.  
  60.     Parameters: localpath, destpath
  61.     
  62.     Returns a relative path to the destination from the local path,
  63.     after removal of any common prefix.
  64.  
  65. =cut
  66.  
  67. sub makeRelativePath
  68. {
  69.     my ( $from, $to ) = @_;
  70.  
  71.     # remove prefix
  72.     $from .= '/' unless $from =~ m#/$#;
  73.     $to .= '/' unless $to =~ m#/$#;
  74.  
  75.     my $pfx = findCommonPrefix( $from, $to );
  76.  
  77.     if ( $pfx ne "" ) {
  78.         $from =~ s/^$pfx//g;
  79.         $to =~ s/^$pfx//g;
  80.     }
  81. #    print "Prefix is '$pfx'\n";
  82.     
  83.     $from =~ s#/+#/#g;
  84.     $to =~ s#/+#/#g;
  85.     $pfx = countReg( $from, '\/' );
  86.  
  87.     my $rel = "../" x $pfx;
  88.     $rel .= $to;
  89.  
  90.     return $rel;
  91. }
  92.  
  93. sub hostName
  94. {
  95.     my $host = "";
  96.     my @hostenvs = qw( HOST HOSTNAME COMPUTERNAME );
  97.  
  98.     # Host name
  99.     foreach my $evar ( @hostenvs ) {
  100.             next unless defined $ENV{ $evar };
  101.  
  102.             $host = $ENV{ $evar };
  103.             last;
  104.     }
  105.  
  106.     if( $host eq "" ) {
  107.             $host = `uname -n`;
  108.             chop $host;
  109.     }
  110.  
  111.     return $host;
  112. }
  113.  
  114. sub userName
  115. {
  116.     my $who = "";
  117.     my @userenvs = qw( USERNAME USER LOGNAME );
  118.  
  119.     # User name
  120.     foreach my $evar ( @userenvs ) {
  121.             next unless defined $ENV{ $evar };
  122.  
  123.             $who = $ENV{ $evar };
  124.             last;
  125.     }
  126.  
  127.     if( $who eq "" ) {
  128.         if ( $who = `whoami` ) {
  129.                 chop $who;
  130.         }
  131.         elsif ( $who - `who am i` ) {
  132.                 $who = ( split (/ /, $who ) )[0];
  133.         }
  134.     }
  135.  
  136.     return $who;
  137. }
  138.  
  139. =head2 splitUnnested
  140.     Helper to split a list using a delimiter, but looking for
  141.     nesting with (), {}, [] and <>.
  142.         Example: splitting   int a, QPair<c,b> d, e=","
  143.     on ',' will give 3 items in the list.
  144.  
  145.     Parameter: delimiter, string
  146.     Returns: array, after splitting the string
  147.  
  148.     Thanks to Ashley Winters
  149. =cut
  150. sub splitUnnested($$) {
  151.     my $delim = shift;
  152.     my $string = shift;
  153.     my(%open) = (
  154.         '[' => ']',
  155.         '(' => ')',
  156.         '<' => '>',
  157.         '{' => '}',
  158.     );
  159.     my(%close) = reverse %open;
  160.     my @ret;
  161.     my $depth = 0;
  162.     my $start = 0;
  163.     my $indoublequotes = 0;
  164.     while($string =~ /($delim|<<|>>|[][}{)(><\"])/g) {
  165.         my $c = $1;
  166.         if(!$depth and !$indoublequotes and $c eq $delim) {
  167.             my $len = pos($string) - $start - 1;
  168.             push @ret, substr($string, $start, $len);
  169.             $start = pos($string);
  170.         } elsif($open{$c}) {
  171.             $depth++;
  172.         } elsif($close{$c}) {
  173.             $depth--;
  174.         } elsif($c eq '"') {
  175.         if ($indoublequotes) {
  176.         $indoublequotes = 0;
  177.         } else {
  178.         $indoublequotes = 1;
  179.         }
  180.     }
  181.     }
  182.  
  183.     my $subs = substr($string, $start);
  184.     push @ret, $subs if ($subs);
  185.     return @ret;
  186. }
  187.  
  188. 1;
  189.  
  190.